﻿// Copyright (c) Stephan Tolksdorf 2008-2009
// License: BSD-style. See accompanying documentation.

module FParsec.Error

open System.Diagnostics
open System.Globalization
open System.IO
open FParsec.Internals

#nowarn "61" // "The containing type can use 'null' as a representation value for its nullary union case. This member will be compiled as a static member."

[<DebuggerDisplay("{GetDebuggerDisplay(),nq}")>]
type ErrorMessage =
     | Expected           of string
     | ExpectedString     of string
     | ExpectedStringCI   of string
     | Unexpected         of string
     | UnexpectedString   of string
     | UnexpectedStringCI of string
     | Message            of string
     | CompoundError      of string * Position * ErrorMessageList
     | BacktrackPoint     of Position * ErrorMessageList
     | OtherError         of System.IComparable
     with
        // the default DebuggerDisplay generated by the F# compiler doesn't use the DebuggerDisplay for ErrorMessageList
        member internal t.GetDebuggerDisplay() =
            let escape s = escapeStringInDoubleQuotes s
            match t with
            | Expected(str)           -> concat3 "Expected \"" (escape str) "\""
            | ExpectedString(str)     -> concat3 "ExpectedString \"" (escape str) "\""
            | ExpectedStringCI(str)   -> concat3 "ExpectedStringCI \"" (escape str) "\""
            | Unexpected(str)         -> concat3 "Unexpected \"" (escape str) "\""
            | UnexpectedString(str)   -> concat3 "UnexpectedString \"" (escape str) "\""
            | UnexpectedStringCI(str) -> concat3 "UnexpectedStringCI \"" (escape str) "\""
            | Message(str)            -> concat3 "Message \"" (escape str) "\""
            | OtherError(o)           -> concat3 "OtherError(" (o.ToString()) ")"
            | CompoundError(str, pos, error)
                -> concat7 "CompoundError(\"" (escape str) "\", " (pos.ToString()) ", " (ErrorMessageList.GetDebuggerDisplay(error)) ")"
            | BacktrackPoint(pos, error)
                -> concat5 "BacktrackPoint(" (pos.ToString()) ", " (ErrorMessageList.GetDebuggerDisplay(error)) ")"


and [<CompilationRepresentation(CompilationRepresentationFlags.UseNullAsTrueValue);
      CustomEquality; CustomComparison>]
    [<DebuggerTypeProxy(typeof<ErrorMessageListDebugView>);
      DebuggerDisplay("{ErrorMessageList.GetDebuggerDisplay(this),nq}")>]
    ErrorMessageList =
    | AddErrorMessage of ErrorMessage * ErrorMessageList
    | NoErrorMessages
    with
        // compiled as static member, so valid for t = null
        member t.ToSet() =
            let rec convert (set: Set<_>) xs =
                match xs with
                | NoErrorMessages -> set
                | AddErrorMessage(hd, tl) ->
                    match hd with
                    // filter out empty messages
                    | Expected(s)
                    | ExpectedString(s)
                    | ExpectedStringCI(s)
                    | Unexpected(s)
                    | UnexpectedString(s)
                    | UnexpectedStringCI(s)
                    | Message(s)
                      when isNullOrEmpty s
                        -> convert set tl
                    | _ -> convert (set.Add(hd)) tl

            convert (Set.empty<ErrorMessage>) t

        static member OfSeq(msgs: seq<ErrorMessage>) =
            msgs |> Seq.fold (fun lst msg -> AddErrorMessage(msg, lst)) NoErrorMessages

        // compiled as instance member, but F#'s operator '=' will handle the null cases
        override t.Equals(value: obj) =
            referenceEquals (t :> obj) value
            ||  match value with
                | null -> false
                | :? ErrorMessageList as other -> compare (t.ToSet()) (other.ToSet()) = 0
                | _ -> false

        interface System.IComparable with
            member t.CompareTo(value: obj) = // t can't be null (i.e. NoErrorMessages)
                match value with
                | null -> 1
                | :? ErrorMessageList as msgs -> compare (t.ToSet()) (msgs.ToSet())
                | _ -> invalidArg "value" "Object must be of type ErrorMessageList."

        override t.GetHashCode() = t.ToSet().GetHashCode()

        static member internal GetDebuggerDisplay(msgs: ErrorMessageList) =
            match msgs with
            | NoErrorMessages -> "NoErrorMessages"
            | _ -> match List.ofSeq (Seq.truncate 3 (msgs.ToSet())) with
                   | []         -> "NoErrorMessages"
                   | [e1]       -> "[" + e1.GetDebuggerDisplay() + "]"
                   | [e1; e2]   -> "[" + e1.GetDebuggerDisplay() + "; " + e2.GetDebuggerDisplay() + "; ...]"
                   | e1::e2::tl -> "[" + e1.GetDebuggerDisplay() + "; " + e2.GetDebuggerDisplay() + "]"


and [<Sealed>]
    ErrorMessageListDebugView(msgs: ErrorMessageList) =
        [<DebuggerBrowsable(DebuggerBrowsableState.RootHidden)>]
        member t.Items = msgs.ToSet() |> Set.toArray

let expectedError           label = AddErrorMessage(Expected(label), NoErrorMessages)
let expectedStringError     str   = AddErrorMessage(ExpectedString(str), NoErrorMessages)
let expectedStringCIError   str   = AddErrorMessage(ExpectedStringCI(str), NoErrorMessages)
let unexpectedError         label = AddErrorMessage(Unexpected(label), NoErrorMessages)
let unexpectedStringError   str   = AddErrorMessage(UnexpectedString(str), NoErrorMessages)
let unexpectedStringCIError str   = AddErrorMessage(UnexpectedStringCI(str), NoErrorMessages)
let messageError            msg   = AddErrorMessage(Message(msg), NoErrorMessages)
let otherError              obj   = AddErrorMessage(OtherError(obj), NoErrorMessages)

let backtrackError (state: State<'u>) error =
    match error with
    | AddErrorMessage(BacktrackPoint _, NoErrorMessages) -> error
    | _ -> AddErrorMessage(BacktrackPoint(state.Position, error), NoErrorMessages)

let compoundError label (state: State<'u>) error =
    match error with
    | AddErrorMessage(BacktrackPoint(pos2, error2), NoErrorMessages)
        -> AddErrorMessage(CompoundError(label, pos2, error2), NoErrorMessages)
    | _ -> AddErrorMessage(CompoundError(label, state.Position, error), NoErrorMessages)

let rec concatErrorMessages msgs msgs2 =
    match msgs2 with
    | AddErrorMessage(hd, tl) -> concatErrorMessages (AddErrorMessage(hd, msgs)) tl
    | NoErrorMessages         -> msgs

let
#if NOINLINE
#else
    inline
#endif
           mergeErrors msgs1 msgs2 =
    match msgs1 with
    | NoErrorMessages -> msgs2
    | _ -> concatErrorMessages msgs1 msgs2

let
#if NOINLINE
#else
    inline
#endif
           mergeErrorsIfNeeded (oldState: State<'u>) oldError (newState: State<'u>) newError =
    if isNull oldError || newState != oldState then newError
    else concatErrorMessages oldError newError

let
#if NOINLINE
#else
    inline
#endif
           mergeErrorsIfNeeded3 (veryOldState: State<'u>) veryOldError
                                (oldState: State<'u>) oldError
                                (newState: State<'u>) newError =
    let error = mergeErrorsIfNeeded veryOldState veryOldError oldState oldError
    mergeErrorsIfNeeded oldState error newState newError

let internal newlineChars = [|'\r'; '\n'; '\u0085'; '\u000C'; '\u2028'; '\u2029'|]

[<System.Obsolete("This function will be removed in a future version of FParsec. If you want to continue to use it, please copy its source code.")>]
let printErrorLine (stream: CharStream) (index: int64) (tw: System.IO.TextWriter) (indent: string) (columnWidth: int) =
    let iter = stream.Seek(index)
    if index > iter.Index then
        invalidArg "index ""The given index lies beyond the end of the given CharStream."
    let space = columnWidth - indent.Length
    if space > 0 then
       let leftBound = max (index - int64 space) stream.BeginIndex
       let off = int32 (index - leftBound)
       let s = iter.Advance(-off).Read(2*space)
       let lineBegin = if off > 0 then s.LastIndexOfAny(newlineChars, off - 1) + 1 else 0
       let lineEnd   = let i = s.IndexOfAny(newlineChars, lineBegin) in if i >= 0 then i else s.Length
       let space = if lineEnd > off then space else space - 1
       let left      = max (min (lineEnd   - space) (off - space/2)) lineBegin
       let right     = min (max (lineBegin + space) (off + (space - space/2))) lineEnd
       if right > left then
           fprintfn tw "%s%s"  indent (s.Substring(left, right - left).Replace('\t', ' '))
           fprintf  tw "%s%s^" indent (new string(' ', off - left))
           if    not iter.IsEndOfStream
              || columnWidth - (indent.Length + off - left + 1) < 14
           then tw.WriteLine()
           else tw.WriteLine("(end of input)")
       elif not iter.IsEndOfStream && columnWidth - indent.Length >= 23 then
           fprintfn tw "%sError on an empty line." indent
       elif iter.IsEndOfStream && columnWidth - indent.Length >= 22 then
           fprintfn tw "%sError at end of input." indent
       else
           tw.WriteLine(if columnWidth >= indent.Length then indent else "")
    else
        tw.WriteLine(if columnWidth = indent.Length then indent else "")


/// the default position printer
let internal printPosition (tw: System.IO.TextWriter) (p: Position) (indent: string) (columnWidth: int) =
    fprintfn tw "%sError in %s%sLn: %i Col: %i"
                indent p.StreamName (if isNullOrEmpty p.StreamName then "" else ": ") p.Line p.Column

let mutable internal tabSize = 8 // not mutated within this library

let internal printErrorPosition (lw: LineWrapper) (stream: CharStream) (p: Position) =
    /// writes the string with all tabs and unicode newline chars replaced with ' '
    let writeStringWithSimplifiedWhitespace (tw: TextWriter) (s: string) =
        let mutable i0 = 0
        for i = 0 to s.Length - 1 do
            let c = s.[i]
            if (if c <= '\r' then c >= '\t'
                else c >= '\u0085' && (c = '\u0085' || c = '\u2028' || c = '\u2029'))
            then
                if i0 < i then
                    tw.Write(s.Substring(i0, i - i0))
                tw.Write(' ')
                i0 <- i + 1
        if i0 < s.Length then
            if i0 = 0 then tw.Write(s)
            else tw.Write(s.Substring(i0, s.Length - i0))

    let sn = getLineSnippet stream p lw.ColumnWidth tabSize lw.WriterIsMultiCharGraphemeSafe
    let str = sn.String

    lw.Print("Error in ")
    if not (isNullOrEmpty p.StreamName) then lw.Print(p.StreamName, ": ")
    lw.Print("Ln: ", string p.Line)
    if sn.UnaccountedNewlines <> 0 then
        lw.Print(" (+", string sn.UnaccountedNewlines, "?)")
    lw.Print(" Col: ", string sn.Column)
    if sn.Column <> sn.Utf16Column then
        lw.Print(" (UTF16-Col: ", string sn.Utf16Column ,")")
    lw.Newline()

    let msgs = new ResizeArray<_>()
    if sn.LineContainsTabsBeforeIndex then
        msgs.Add(concat4 "The column count assumes a tab stop distance of " (tabSize.ToString()) " chars."
                          (if sn.Column <> sn.Utf16Column then
                              " The UTF-16 column count only counts each tab as 1 char."
                           else ""))

    if str.Length > 0 then
        let tw = lw.TextWriter
        writeStringWithSimplifiedWhitespace tw str
        tw.WriteLine()
        if sn.TextElementIndex > 0 then
            tw.Write(new string(' ', sn.TextElementIndex))
        tw.Write('^')
        let d = sn.Index - sn.TextElementIndex
        if d <> 0 && not lw.WriterIsMultiCharGraphemeSafe then
            if d > 1 then
                tw.Write(new string('-', d - 1))
            tw.Write('^')
            msgs.Add("The exact error position between the two ^ depends on the unicode capabilities of the display.")
        tw.WriteLine()

    if sn.Index < str.Length then
        let i = sn.Index
        let c = str.[i]
        if System.Char.IsSurrogate(c) then
            if Helper.IsHighSurrogate(c) then
                if i + 1 < str.Length && Helper.IsLowSurrogate(str.[i + 1]) then
                    msgs.Add(concat3 "The error occurred at the beginning of the surrogate pair " (asciiQuoteString (str.Substring(i, 2))) ".")
                else
                    msgs.Add(concat3 "The char at the error position ('" (hexEscapeChar c) "') is an isolated high surrogate.")
            else // low surrogate
                if i > 0 && Helper.IsHighSurrogate(str.[i - 1]) then
                    msgs.Add(concat3 "The error occurred at the second char in the surrogate pair " (asciiQuoteString (str.Substring(i - 1, 2))) ".")
                else
                    msgs.Add(concat3 "The char at the error position ('" (hexEscapeChar c) "') is an isolated low surrogate.")
        elif i > 0 && Helper.IsHighSurrogate(str.[i - 1]) then
            msgs.Add(concat3 "The char before the error position ('" (hexEscapeChar (str.[i - 1])) "') is an isolated high surrogate.")
    else
        if p.Index = stream.EndIndex then msgs.Add("The error occurred at the end of the input stream.")
        elif str.Length = 0 then msgs.Add("The error occured on an empty line.")
        else msgs.Add("The error occurred at the end of the line.")

    if sn.LengthOfTextElement > 1 && (sn.LengthOfTextElement > 2 || not (System.Char.IsSurrogate(str.[sn.Index]))) then
        let te = str.Substring(sn.IndexOfTextElement, sn.LengthOfTextElement)
        let n = sn.Index - sn.IndexOfTextElement + 1
        msgs.Add(concat6 "The error occurred at the " (string n) (ordinalEnding n) " char in the combining character sequence " (asciiQuoteString te) ".")
    elif sn.IsBetweenCRAndLF then
        msgs.Add("The error occured at the 2nd char in the newline char sequence '\r\n'.")

    if sn.UnaccountedNewlines > 0 then
        let n = sn.UnaccountedNewlines
        msgs.Add(concat6 "The input contains at least " (string n) (if n = 1 then " newline " else " newlines " ) "in the input that " (if n = 1 then "wasn't" else "weren't ") " properly registered in the parser state.")

    if msgs.Count = 1 then lw.PrintLine("Note: ", msgs.[0])
    elif msgs.Count > 1 then
        let ind  = lw.Indentation
        let ind2 = ind + "  "
        lw.PrintLine("Note:")
        for msg in msgs do
            lw.Print("* ")
            lw.Indentation <- ind2
            lw.PrintLine(msg)
            lw.Indentation <- ind

[<Sealed>]
type ParserError(position: Position, error: ErrorMessageList) =
    do if isNull position then nullArg "pos"

    let defaultColumnWidth = 79
    let defaultIndentation = ""
    let defaultIndentationIncrement = "  "

    member t.Position = position
    member T.Error = error

    override t.ToString() =
        use sw = new System.IO.StringWriter()
        t.WriteTo(sw)
        sw.ToString()

    member t.ToString(streamWhereErrorOccurred: CharStream) =
        use sw = new System.IO.StringWriter()
        t.WriteTo(sw, streamWhereErrorOccurred)
        sw.ToString()

    member t.WriteTo(textWriter: System.IO.TextWriter,
                     ?positionPrinter: (System.IO.TextWriter -> Position -> string -> int -> unit),
                     ?columnWidth: int, ?initialIndentation: string, ?indentationIncrement: string) =

        let positionPrinter = defaultArg positionPrinter printPosition
        let columnWidth     = defaultArg columnWidth defaultColumnWidth
        let ind             = defaultArg initialIndentation defaultIndentation
        let indIncrement    = defaultArg indentationIncrement defaultIndentationIncrement
        let lw = new LineWrapper(textWriter, columnWidth, Indentation = ind)
        t.WriteTo(lw, positionPrinter, indIncrement)

    member t.WriteTo(textWriter: System.IO.TextWriter,
                     streamWhereErrorOccurred: CharStream,
                     ?columnWidth: int, ?initialIndentation: string, ?indentationIncrement: string) =

        let originalStreamName = t.Position.StreamName
        let getStreamByName = fun streamName -> if streamName = originalStreamName then streamWhereErrorOccurred else null
        t.WriteTo(textWriter, getStreamByName, ?columnWidth = columnWidth, ?initialIndentation = initialIndentation, ?indentationIncrement = indentationIncrement)

    member t.WriteTo(textWriter: System.IO.TextWriter,
                     getStreamByname: (string -> CharStream),
                     ?columnWidth: int, ?initialIndentation: string, ?indentationIncrement: string) =

        let columnWidth  = defaultArg columnWidth defaultColumnWidth
        let ind          = defaultArg initialIndentation defaultIndentation
        let indIncrement = defaultArg indentationIncrement defaultIndentationIncrement
        let lw = new LineWrapper(textWriter, columnWidth, Indentation = ind)
        let positionPrinter =
            fun tw (pos: Position) indent columnWidth ->
                let stream = getStreamByname pos.StreamName
                if isNotNull stream then
                   printErrorPosition lw stream pos
                else
                   printPosition lw.TextWriter pos indent columnWidth
        t.WriteTo(lw, positionPrinter, indIncrement)

    member private t.WriteTo(lw: LineWrapper,
                             positionPrinter: System.IO.TextWriter -> Position -> string -> int -> unit,
                             indentationIncrement: string) =

        let rec printMessages (position: Position) (msgs: ErrorMessageList) =
            positionPrinter lw.TextWriter position lw.Indentation lw.ColumnWidth
            let nra() = new ResizeArray<_>()
            let expectedA, unexpectedA, messageA, compoundA, backtrackA = nra(), nra(), nra(), nra(), nra()
            let mutable otherCount = 0
            for msg in msgs.ToSet() do // iterate over ordered unique messages
                match msg with
                | Expected s           -> expectedA.Add(s)
                | ExpectedString s     -> expectedA.Add(quoteString s)
                | ExpectedStringCI s   -> expectedA.Add(quoteString s + " (case-insensitive)")
                | Unexpected s         -> unexpectedA.Add(s)
                | UnexpectedString s   -> unexpectedA.Add(quoteString s)
                | UnexpectedStringCI s -> unexpectedA.Add(quoteString s + " (case-insensitive)")
                | Message s    -> messageA.Add(s)
                | OtherError obj -> otherCount <- otherCount + 1
                | CompoundError (s, pos2, msgs2) ->
                    if not (isNullOrEmpty s) then expectedA.Add(s)
                    compoundA.Add((s, pos2, msgs2))
                | BacktrackPoint (pos2, msgs2) ->
                    backtrackA.Add((pos2, msgs2))
            let printArray title (a: ResizeArray<string>) (sep: string) =
                lw.Print(title, ": ")
                let n = a.Count
                for i = 0 to n - 3 do
                    lw.Print(a.[i], ", ")
                if n > 1 then lw.Print(a.[n - 2], sep)
                if n > 0 then lw.Print(a.[n - 1])
                lw.Newline()
            if expectedA.Count > 0 then
                printArray "Expecting" expectedA " or "
            if unexpectedA.Count > 0 then
                printArray "Unexpected" unexpectedA " and "
            let ind = lw.Indentation
            let indInd = ind + indentationIncrement
            if messageA.Count > 0 then
                if expectedA.Count > 0 || unexpectedA.Count > 0 then
                    lw.PrintLine("Other errors:")
                    lw.Indentation <- indInd
                for m in messageA do
                    lw.PrintLine(m)
                if expectedA.Count > 0 || unexpectedA.Count > 0 then
                    lw.Indentation <- ind
            for s, pos2, msgs2 in compoundA do
                lw.Newline()
                lw.PrintLine(s, " could not be parsed because:")
                lw.Indentation <- indInd
                printMessages pos2 msgs2
                lw.Indentation <- ind
            for pos2, msgs2 in backtrackA do
                lw.Newline()
                lw.PrintLine("The parser backtracked after:")
                lw.Indentation <- indInd
                printMessages pos2 msgs2
                lw.Indentation <- ind
            if    expectedA.Count = 0 && unexpectedA.Count = 0 && messageA.Count = 0
               && compoundA.Count = 0 && backtrackA.Count = 0
            then
                lw.PrintLine("Unknown error(s)")
        printMessages position error

    override t.Equals(value: obj) =
        referenceEquals (t :> obj) value
        ||  match value with
            | null -> false
            | :? ParserError as other -> t.Position = other.Position && t.Error = other.Error
            | _ -> false

    override t.GetHashCode() = t.Position.GetHashCode() ^^^ t.Error.GetHashCode()

    interface System.IComparable with
        member t.CompareTo(value) =
            match value with
            | null -> 1
            | :? ParserError as other ->
                if isNotNull t.Position then
                    let r = t.Position.CompareTo(other.Position)
                    if r <> 0 then r
                    else compare error other.Error
                elif isNull other.Position then compare error other.Error
                else -1
            | _ -> invalidArg "value" "Object must be of type ParserError."

let _raiseInfiniteLoopException (name: string) (state: State<'u>) =
    failwith (concat4 (state.Position.ToString()) ": The combinator '" name "' was applied to a parser that succeeds without consuming input and without changing the parser state in any other way. (If no exception had been raised, the combinator likely would have entered an infinite loop.)")
